Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/misc/vb3utils/general.bas

BASIC Source File | 1996-01-08 | 9.6 KB | 259 lines

Option Explicit

Const SWP_NOMOVE = 2
Const SWP_NOSIZE = 1
Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2

Const SW_RESTORE = 9
Const SW_SHOWNORMAL = 1
Const SW_SHOWMINIMIZED = 2
Const SW_SHOWMAXIMIZED = 3

Global Const WPR_LEFT = &H1
Global Const WPR_TOP = &H2
Global Const WPR_LEFTTOP = WPR_LEFT + WPR_TOP
Global Const WPR_WIDTH = &H4
Global Const WPR_HEIGHT = &H8
Global Const WPR_WIDTHHEIGHT = WPR_WIDTH + WPR_HEIGHT
Global Const WPR_STATE = &H10
Global Const WPR_ALL = WPR_LEFTTOP + WPR_WIDTHHEIGHT + WPR_STATE

Global Const SND_SYNC = &H0               ' play synchronously (default)
Global Const SND_ASYNC = &H1              ' play asynchronously
Global Const SND_NODEFAULT = &H2          ' don't use default sound
Global Const SND_MEMORY = &H4             ' lpszSoundName points to a memory file
Global Const SND_LOOP = &H8               ' loop the sound until next sndPlaySound
Global Const SND_NOSTOP = &H10            ' don't stop any currently playing sound

Type POINTAPI
    x As Integer
    y As Integer
End Type

Type RECT
    left As Integer
    top As Integer
    right As Integer
    bottom As Integer
End Type

Type WINDOWPLACEMENT
    length As Integer
    Flags As Integer
    showCmd As Integer
    ptMinPosition As POINTAPI
    ptMaxPosition As POINTAPI
    rcNormalPosition As RECT
End Type

Declare Function GAW% Lib "User" Alias "GetActiveWindow" ()
Declare Function SWP% Lib "user" Alias "SetWindowPos" (ByVal h%, ByVal hb%, ByVal x%, ByVal y%, ByVal cx%, ByVal cy%, ByVal f%)
Declare Function FW% Lib "user" Alias "FindWindow" (ByVal lpClassName As Any, ByVal lpCaption As Any)
Declare Function SW% Lib "User" Alias "ShowWindow" (ByVal Handle As Integer, ByVal Cmd As Integer)
Declare Function SF% Lib "User" Alias "SetFocus" (ByVal Handle As Integer)

Declare Function GPPS% Lib "Kernel" Alias "GetPrivateProfileString" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String)
Declare Function GPS% Lib "Kernel" Alias "GetProfileString" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer)
Declare Function WPPS% Lib "Kernel" Alias "WritePrivateProfileString" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpString As Any, ByVal lplFileName As String)
Declare Function WPS% Lib "Kernel" Alias "WriteProfileString" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpString As Any)

Declare Function GWPlc% Lib "User" Alias "GetWindowPlacement" (ByVal hWnd As Integer, lpwndpl As WINDOWPLACEMENT)
Declare Function SWPlc% Lib "User" Alias "SetWindowPlacement" (ByVal hWnd As Integer, lpwndpl As WINDOWPLACEMENT)

Declare Function Sound1% Lib "mmsystem" Alias "sndPlaySound" (ByVal lpSoundName As String, ByVal Flags As Integer)
Declare Function Sound0% Lib "mmsystem" Alias "sndPlaySound" (ByVal lpSoundName As Any, ByVal Flags As Integer)

' NOTE: Does not return if duplicate found !!
'
Sub ExitIfAlreadyRunning ()
Dim Title$, Handle%, junk%
    ' Get App title
    Title$ = App.Title
    ' Set it to something unlikely ...
    App.Title = "TestingForDuplicate"
    ' Search for another app with my title
    Handle% = FW(0&, Title$)
    ' Set my App's title back to what it was
    App.Title = Title$
    ' If another copy was found ...
    If Handle% <> 0 Then
    ' Handle% will probably point to App, so we
    '  need to give the App the focus to find it's
    '  Main Window ...
    junk% = SF(Handle%)
    ' ... Get the window ...
    Handle% = GAW()
    ' ... and restore it if possible
    If Handle% <> 0 Then
        junk% = SW(Handle%, SW_RESTORE)
        ' Now exit myself and it's done !
        End
    End If
    End If
End Sub

' Sets a window to be floating or non-floating
' Pass form, true for floating, false for not
' returns true if successful, otherwise false
Function FormFloat (FloatForm As Form, Floating%) As Integer
Const Flags = SWP_NOMOVE Or SWP_NOSIZE
Dim success%
    If Floating Then
    success% = SWP(FloatForm.hWnd, HWND_TOPMOST, 0, 0, 0, 0, Flags)
    Else
    success% = SWP(FloatForm.hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, Flags)
    End If
    ' success% <> 0 When Successful
    FormFloat = success%
End Function

Function GetPrivateProfileString (ByVal ApplicationName As String, KeyName As String, default As String, Size As Integer, FileName As String) As String
Dim TmpStr As String, retcode As Integer
    GetPrivateProfileString = ""
    If ApplicationName = "" Then
    ApplicationName = App.Title
    End If
    TmpStr = String$(Size, 0)
    retcode = GPPS(ApplicationName, KeyName, default, TmpStr, Size, FileName)
    If retcode > 0 Then
    GetPrivateProfileString = Left$(TmpStr, retcode)
    End If
End Function

Function GetProfileString (ByVal ApplicationName As String, KeyName As String, default As String, Size As Integer) As String
Dim TmpStr As String, retcode As Integer
    GetProfileString = ""
    If ApplicationName = "" Then
    ApplicationName = App.Title
    End If
    TmpStr = String$(Size, 0)
    retcode = GPS(ApplicationName, KeyName, default, TmpStr, Size)
    If retcode > 0 Then
    GetProfileString = Left$(TmpStr, retcode)
    End If
End Function

' Plays sound defined in WIN.INI [Sounds]
'
Function PlaySound (SoundName As String)
    PlaySound = Sound1%(SoundName, SND_ASYNC)
End Function

' Plays sound defined in WIN.INI [Sounds]
'  Flags defined in [Declarations]
'
Function PlaySoundExt (SoundName As String, Flags As Integer)
    PlaySoundExt = Sound1%(SoundName, Flags)
End Function

' Restores a form's position from WIN.INI under heading AppName
' If AppName = "" use App.Title
' Flags defined in [Declarations]. Can be used to only restore
' parts of the position. i.e. only restore Left & Top without
' restoring Width, Height, and State
'
' This is usually called after form is loaded, but before it is
' 'Show'n.
'
Function RestoreWindowPos (AppForm As Form, AppName As String, Flags As Integer) As Integer
Dim WindowPos As WINDOWPLACEMENT
Dim retcode As Integer
Dim PosStr As String, Comma As Integer
    retcode = False
    PosStr = GetProfileString(AppName, "WindowPosition", "", 255)
    If PosStr <> "" Then
    WindowPos.length = 22
    WindowPos.Flags = 0
    If Left$(PosStr, 1) = "[" And Right$(PosStr, 1) = "]" Then
        PosStr = Mid$(PosStr, 2, Len(PosStr) - 2) + ","
        Comma = InStr(PosStr, ",")
        If Comma > 1 Then
        If (Flags And WPR_LEFT) Then
            WindowPos.rcNormalPosition.left = Val(Left$(PosStr, Comma - 1))
        Else
            WindowPos.rcNormalPosition.left = Int(AppForm.Left / screen.TwipsPerPixelX)
        End If
        PosStr = Mid$(PosStr, Comma + 1)
        Comma = InStr(PosStr, ",")
        If Comma > 1 Then
            If (Flags And WPR_TOP) Then
            WindowPos.rcNormalPosition.top = Val(Left$(PosStr, Comma - 1))
            Else
            WindowPos.rcNormalPosition.top = Int(AppForm.Top / screen.TwipsPerPixelY)
            End If
            PosStr = Mid$(PosStr, Comma + 1)
            Comma = InStr(PosStr, ",")
            If Comma > 1 Then
            If (Flags And WPR_WIDTH) Then
                WindowPos.rcNormalPosition.right = WindowPos.rcNormalPosition.left + Val(Left$(PosStr, Comma - 1))
            Else
                WindowPos.rcNormalPosition.right = WindowPos.rcNormalPosition.left + Int(AppForm.Width / screen.TwipsPerPixelX)
            End If
            PosStr = Mid$(PosStr, Comma + 1)
            Comma = InStr(PosStr, ",")
            If Comma > 1 Then
                If (Flags And WPR_HEIGHT) Then
                WindowPos.rcNormalPosition.bottom = WindowPos.rcNormalPosition.top + Val(Left$(PosStr, Comma - 1))
                Else
                WindowPos.rcNormalPosition.bottom = WindowPos.rcNormalPosition.top + Int(AppForm.Height / screen.TwipsPerPixelY)
                End If
                PosStr = Mid$(PosStr, Comma + 1)
                Comma = InStr(PosStr, ",")
                If Comma > 1 Then
                If (Flags And WPR_STATE) Then
                    WindowPos.showCmd = Val(Left$(PosStr, Comma - 1))
                Else
                    WindowPos.showCmd = IIf(AppForm.WindowState = 1, SW_SHOWMINIMIZED, IIf(AppForm.WindowState = 2, SW_SHOWMAXIMIZED, SW_SHOWNORMAL))
                End If
                retcode = True
                End If
            End If
            End If
        End If
        End If
        If retcode Then
        retcode = SWPlc(AppForm.hWnd, WindowPos)
        End If
    End If
    End If
    RestoreWindowPos = retcode
End Function

' Saves a form's position in WIN.INI under heading AppName
' If AppName = "" use App.Title
'
Function SaveWindowPos (AppForm As Form, AppName As String) As Integer
Dim WindowPos As WINDOWPLACEMENT, retcode As Integer
Dim PosStr As String
    WindowPos.length = 22
    retcode = GWPlc(AppForm.hWnd, WindowPos)
    If retcode Then
    PosStr = "[" + CStr(WindowPos.rcNormalPosition.left) + "," + CStr(WindowPos.rcNormalPosition.top) + "," + CStr(WindowPos.rcNormalPosition.right) + "," + CStr(WindowPos.rcNormalPosition.bottom) + "," + CStr(WindowPos.showCmd) + "]"
    retcode = WriteProfileString(AppName, "WindowPosition", PosStr)
    End If
    SaveWindowPos = retcode
End Function

' Stops any ASYNC sound being played.
'
Sub StopSound ()
Dim junk As Integer
    junk = Sound0%(0&, 0)
End Sub

Function WritePrivateProfileString (ByVal ApplicationName As String, KeyName As String, Value As String, FileName As String) As Integer
    If ApplicationName = "" Then
    ApplicationName = App.Title
    End If
    WritePrivateProfileString = WPPS(ApplicationName, KeyName, Value, FileName)
End Function

Function WriteProfileString (ByVal ApplicationName As String, KeyName As String, Value As String) As Integer
    If ApplicationName = "" Then
    ApplicationName = App.Title
    End If
    WriteProfileString = WPS(ApplicationName, KeyName, Value)
End Function